home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Interface Toolkit-2.01 / Dialog-Editor.Lisp next >
Encoding:
Text File  |  1993-09-16  |  42.8 KB  |  1,092 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;  dialog-editor.lisp
  3. ;;
  4. ;;
  5. ;;  ©1989,1990,1991 Apple Computer, Inc
  6. ;;
  7. ;;  the main code of the dialog-editor portion of the interface designer
  8. ;;
  9.  
  10. ;;;;;;;;;;;;;;;;;;;;
  11. ;;
  12. ;; Change History
  13. ;;
  14. ;; 04/28/93 mwp Release
  15. ;; 07/22/92 bill  Luke Hohmann's view-key-event-handler
  16. ;; 04/08/92 bill  make sloppy-find-view-containing-point search from front to back.
  17. ;; -------------- 2.0
  18. ;; 01/09/91 alice put back  cut etal:around methods, update edit-menu in select-and-add-xx -??????
  19. ;;          select-all was broken
  20. ;; 12/29/91 alice window-do-operation has another argument
  21. ;; 12/18/91 bill  prevent errors in remove-editable-dialog-item
  22. ;; -------------  2.0b4
  23. ;; 11/05/91 bill  nuke nfunction
  24. ;; 10/15/91 alice remove window-can-undo-p, add window-can-do-operation.
  25. ;;        Advise window-do-operation to do cut etal inline instead of via
  26. ;;        :around methods because there are no longer any methods for them to be :around.
  27. ;; 09/23/91 bill #'(setf view-nick-name) -> #'set-view-nick-name
  28. ;; 09/09/91 bill show item-palette only after adding subviews
  29. ;; 09/06/91 bill autosize the item-palette, (use-dialogs) on close-box click in item-palette
  30. ;; 08/12/91 alice lets not die in select-all;;
  31. ;; 07/26/91 bill WINDOW-CAN-UNDO-p was mis-parenthesized, CLEAR was brain-damaged
  32. ;;               GROW-ITEM-OUTLINE needed to constain mouse movement
  33. ;; 02/07/91 bill move-selected-dialog-items fixed for user dragging outside of window
  34. ;; *2.0b1*
  35. ;; 01/30/91 bill select-and-add-dialog-item takes a mouse-pos parameter and
  36. ;;               shows an outline on all monitors.
  37. ;;
  38.  
  39. (in-package :interface-tools)
  40.  
  41. ;;;;;;;;;;;;;;;;;;;;
  42. ;;
  43. ;; misc
  44. ;;
  45.  
  46. (proclaim '(special *dialog-change-undohook* *selected-dialog-items*
  47.             *dialog-item-scrap* *grow-cursor*))
  48.  
  49.  
  50. ;;;;;;;;;;;;;;;;;;;;;;;;;
  51. ;;
  52. ;; variables & classes
  53. ;;
  54.  
  55.  
  56. (defvar *guide-gravity* 3
  57.   "how far you can be from a guide to still snap to it")
  58.  
  59. (defclass window-type-r-b (radio-button-dialog-item)
  60.   ((attribute :initarg :attribute :accessor dialog-item-attribute)))
  61.  
  62. (defclass frame-window-r-b (window-type-r-b)
  63.   ())
  64.  
  65. (defclass box-window-r-b (window-type-r-b)
  66.   ())
  67.  
  68. (defclass dialog-editor (non-editable-dialog)
  69.   ((edited-dialog :initarg :dialog :accessor dialog-editor-dialog))
  70.   (:default-initargs :window-type :document
  71.                      :view-position '(:top 100)
  72.                      :view-size #@(372 68)
  73.                      :window-show nil
  74.                      :close-box-p nil)
  75. )
  76.  
  77. (defvar *prototype-dialog-items* '())
  78.  
  79. (defvar *current-item-palette* nil)
  80.  
  81. (defparameter *item-palette-size* #@(150 100))
  82.  
  83. (defparameter *item-palette-position* (make-point (min (+ (point-h *item-palette-size*)
  84.                                                           (truncate *screen-width* 2))
  85.                                                        (- *screen-width*
  86.                                                           (point-h *item-palette-size*)))
  87.                                                   70))
  88.  
  89.  
  90. (defclass item-palette (windoid non-editable-dialog)
  91.   ())
  92.  
  93.  
  94. ;;;;;;;;;;;;;;;;;;;;;;;;
  95. ;;
  96. ;;  definitions and redefinitions for the *dialog* class
  97. ;;
  98.  
  99. (defmacro get-window-type (window)
  100.   `(view-get ,window 'window-type))
  101.  
  102. (defmacro get-vertical-guides (window)
  103.   `(view-get ,window 'vertical-guides))
  104.  
  105. (defmacro get-horizontal-guides (window)
  106.   `(view-get ,window 'horizontal-guides))
  107.  
  108. (defmethod initialize-instance :around ((window window) &key
  109.                                         window-type)
  110.   (declare (dynamic-extent initargs))
  111.   (prog1
  112.     (call-next-method)
  113.     (setf (get-window-type window) window-type)
  114.     (setf (get-vertical-guides window) ())
  115.     (setf (get-horizontal-guides window) ())))
  116.  
  117. (defmethod window-update-cursor :around ((window window) where)
  118.   (declare (ignore where))
  119.   (if (ccl::editing-dialogs-p window)
  120.     (set-cursor (if (command-key-p)
  121.                   *grow-cursor*
  122.                   *cross-hair-cursor*))
  123.     (call-next-method)))
  124.  
  125. (defmethod view-draw-contents :around ((window window))
  126.   (call-next-method)
  127.   (when (ccl::editing-dialogs-p window)
  128.     (draw-dialog-guides window)
  129.     (highlight-selected-items window t t)))
  130.  
  131. (defmethod view-deactivate-event-handler :around ((window window))
  132.   (call-next-method)
  133.   (setq *dialog-change-undohook* nil)
  134.   (when *selected-dialog-items*
  135.     (reset-selected-item-list window)))
  136.  
  137. (defun sloppy-find-view-containing-point (view point slop)
  138.   (let* ((views (view-subviews view)))
  139.     (do* ((i (1- (length views)) (1- i))
  140.           subview)
  141.          ((< i 0))
  142.       (setq subview (aref views i))
  143.       (let* ((tl (view-position subview))
  144.              (br (add-points tl (view-size subview)))
  145.              (top (ccl::%i- (point-v tl) slop))
  146.              (bottom (ccl::%i+ (point-v br) slop))
  147.              (left (ccl::%i- (point-h tl) slop))
  148.              (right (ccl::%i+ (point-h br) slop))
  149.              (h (point-h point))
  150.              (v (point-v point)))
  151.         (when (and (ccl::%i<= top v)
  152.                    (ccl::%i<= v bottom)
  153.                    (ccl::%i<= left h)
  154.                    (ccl::%i<= h right))
  155.           (return subview))))))
  156.  
  157. (defmethod view-click-event-handler :around ((window window) where &aux
  158.                                              (move-p (ccl::editing-dialogs-p window))
  159.                                              (item (sloppy-find-view-containing-point 
  160.                                                     window where 3)))
  161.   (setq *dialog-change-undohook* nil)
  162.   (if move-p
  163.       (with-focused-view window
  164.         (cond ((command-key-p)
  165.                (grow-or-move-window window where))
  166.               ((or (memq (point-h where) (get-vertical-guides window))
  167.                    (memq (point-v where) (get-horizontal-guides window)))
  168.                (drag-guide window where))
  169.               (item
  170.                ;move, resize, or edit the item
  171.                (if (double-click-p)
  172.                  (edit-dialog-item item)
  173.                  (let ((was-selected (dialog-item-selected-p item)))
  174.                    (if (shift-key-p)
  175.                      (grow-or-move-dialog-item window where item was-selected)
  176.                      (progn
  177.                        (unless was-selected
  178.                          (reset-selected-item-list window))
  179.                        (grow-or-move-dialog-item window where item nil))))))
  180.               (t (select-several-items window where))))
  181.       (call-next-method)))
  182.  
  183. (defmethod view-key-event-handler :around ((window window) char)
  184.   (if (and (ccl::editing-dialogs-p window)
  185.            (member char '(#\UpArrow #\ForwardArrow #\BackArrow #\DownArrow)))
  186.     (with-focused-view window
  187.       (dolist (item *selected-dialog-items*)
  188.         (highlight-one-selected-item window item t nil)
  189.         (set-view-position 
  190.          item
  191.          (case char
  192.            (#\UpArrow      (add-points (view-position item) #@(0 -1)))
  193.            (#\ForwardArrow (add-points (view-position item) #@(1 0)))
  194.            (#\BackArrow    (add-points (view-position item) #@(-1 0)))
  195.            (#\DownArrow    (add-points (view-position item) #@(0 1)))))
  196.         (highlight-one-selected-item window item t t)))
  197.     (call-next-method)))
  198.  
  199. ;;;;;;;;;;;
  200. ;;
  201. ;; cut/copy/paste/clear/select-all
  202. ;;
  203.  
  204.  
  205. (defmethod copy-selected-dialog-items ((window window))
  206.   (mapcar #'(lambda (item)
  207.               (copy-instance item))
  208.           *selected-dialog-items*))
  209.  
  210.  
  211. (defmethod cut :around ((window window))
  212.   (if (ccl::editing-dialogs-p window)
  213.       (progn (setq *dialog-item-scrap* *selected-dialog-items*)
  214.              (clear window))
  215.       (when (next-method-p)(call-next-method))))
  216.  
  217. (defmethod copy :around ((window window))
  218.   (if (ccl::editing-dialogs-p window)
  219.       (setq *dialog-item-scrap* (copy-selected-dialog-items window))
  220.       (when (next-method-p)(call-next-method))))
  221.  
  222. (defmethod paste :around ((window window))
  223.   (if (ccl::editing-dialogs-p window)
  224.       (let ((items *dialog-item-scrap*))
  225.         (if items
  226.             (progn
  227.               (setq *dialog-change-undohook*
  228.                     (cons "Undo Paste"
  229.                           #'(lambda ()
  230.                               (apply
  231.                                 #'remove-subviews window items)
  232.                               (setq *dialog-item-scrap* items
  233.                                     *dialog-change-undohook* nil))))
  234.               (apply
  235.                 #'add-subviews window items)
  236.               (setq *dialog-item-scrap* ()))
  237.             (message-dialog "No items to paste!")))
  238.       (call-next-method)))
  239.  
  240. (defmethod clear :around ((window window))
  241.   (if (ccl::editing-dialogs-p window)
  242.       (let* ((items *selected-dialog-items*))
  243.         (if items
  244.             (progn 
  245.               (setq *dialog-change-undohook*
  246.                     (cons "Undo Clear"
  247.                           #'(lambda ()
  248.                               (reset-selected-item-list window)
  249.                               (apply
  250.                                 #'add-subviews window items)
  251.                               (dolist (item items)
  252.                                 (select-dialog-item window item))
  253.                               (setq *dialog-change-undohook* nil))))
  254.               (apply
  255.                 #'remove-subviews window items))
  256.             (message-dialog "No items to remove!")))
  257.       (when (next-method-p)(call-next-method))))
  258.  
  259. (defmethod select-all :around ((window window))
  260.   (if (ccl::editing-dialogs-p window)
  261.     (dolist (item (dialog-items window))
  262.       (select-dialog-item window item))
  263.     (when (next-method-p)(call-next-method))))
  264.  
  265. (defmethod undo :around ((window window))
  266.   (if (ccl::editing-dialogs-p window)
  267.     (funcall (cdr *dialog-change-undohook*))
  268.     (when (next-method-p)(call-next-method))))
  269.  
  270.  
  271. (defmethod window-can-do-operation :around ((window window) op &optional item)
  272.   (cond
  273.    ((ccl::editing-dialogs-p window)
  274.     (case op
  275.       (undo 
  276.        (when *dialog-change-undohook*
  277.          (set-menu-item-title item (car *dialog-change-undohook*))
  278.          t))
  279.       (select-all
  280.        (dialog-items window))
  281.       ((clear copy cut) *selected-dialog-items*)
  282.       (paste *dialog-item-scrap*)))
  283.    ((next-method-p)(call-next-method))))
  284.  
  285. ;;;;;;;;;;;;;;;;;;;;;;;;;
  286. ;;
  287. ;;  definitions and redefinitions for dialog-items
  288. ;;
  289.  
  290. (defvar *dialog-item-editor-hash* (make-hash-table :test 'eq :weak t))
  291.  
  292. (defun get-dialog-item-editor (item)
  293.   (gethash item *dialog-item-editor-hash*))
  294.  
  295. (defun (setf get-dialog-item-editor) (editor item)
  296.   (if editor
  297.     (setf (gethash item *dialog-item-editor-hash*) editor)
  298.     (remhash item *dialog-item-editor-hash*))
  299.   editor)
  300.  
  301. (defun dialog-item-selected-p (item)
  302.   (member item *selected-dialog-items* :test #'eq))
  303.  
  304. (defmethod remove-view-from-window :around ((item dialog-item))
  305.   (when (dialog-item-selected-p item)
  306.     (unselect-dialog-item (view-container item) item))
  307.   (call-next-method))
  308.  
  309. (defmethod (setf wptr) :around (new-wptr (item dialog-item))
  310.   (when (null new-wptr)
  311.     (let* ((my-ed (get-dialog-item-editor item)))
  312.       (when my-ed
  313.         (window-close my-ed)
  314.         (setf (get-dialog-item-editor item) nil))))
  315.   (call-next-method))
  316.  
  317. ; Patch the method for simple-view
  318. (defmethod view-contains-point-p ((item dialog-item) point)
  319.   (let* ((offset (if (ccl::editing-dialogs-p (view-container item)) 3 0))
  320.          (point-h (point-h point))
  321.          (point-v (point-v point))
  322.          (item-p (view-position item))
  323.          (item-s (view-size item))
  324.          (item-left (- (point-h item-p) offset))
  325.          (item-right (+ offset offset
  326.                         item-left (point-h item-s))))
  327.       (when (< item-left point-h item-right)
  328.         (let*
  329.           ((item-top (- (point-v item-p) offset))
  330.            (item-bottom (+ offset offset
  331.                            item-top (point-v item-s))))
  332.           (< item-top point-v item-bottom)))))
  333.  
  334. (defmethod new-action-from-dialog ((item dialog-item))
  335.   (let ((*save-definitions* t))
  336.     (setf (dialog-item-action-function item)
  337.            (eval (read-from-string
  338.                   (get-text-from-user
  339.                    "Please enter text for the dialog-item-action:"
  340.                    (dialog-item-action-source item)))))))
  341.  
  342. (defmethod dialog-item-action-source ((item dialog-item) &aux old-source)
  343.   (let* ((*print-pretty* t))
  344.   (format nil
  345.           "(function~%  ~a)"
  346.           (let ((f (dialog-item-action-function item)))
  347.             (if f
  348.               (or (and (setq old-source (uncompile-function f))
  349.                        (format nil "~s" old-source))
  350.                   "  (lambda (item)
  351. ;The previous source code for the action could not be found.
  352. ;Perhaps the code for the dialog was loaded from a fasl file,
  353. ;or was compiled with *save-definitions* bound to nil
  354. )")
  355.               "  (lambda (item)
  356.       item
  357. ;Enter action source code here.
  358. )")))))
  359.  
  360. (defmethod set-item-nick-name ((item dialog-item))
  361.   (let ((new-name (read-from-string
  362.                    (get-string-from-user "Enter a nick-name for the item."
  363.                                          :initial-string (string (or (view-nick-name item)
  364.                                                                      ""))))))
  365.     (set-view-nick-name item new-name)))
  366.  
  367. ;;;;;;;;;;;;;;;;;;;;;;;;
  368. ;;
  369. ;; support for moving and resizing windows
  370. ;;
  371.  
  372.  
  373. (defmethod grow-or-move-window ((window window) where)
  374.   (if (double-click-p)
  375.       (edit-dialog window)              ;code for this is down at the bottom
  376.       (let* ((wptr (wptr window))
  377.              (global-where (ccl::%local-to-global wptr where))
  378.              (w-size (view-size window)))
  379.         (reset-selected-item-list window)
  380.         (if (and (> 15 (- (point-h w-size)
  381.                           (point-h where)))
  382.                  (> 15 (- (point-v w-size)
  383.                           (point-v where))))
  384.             (grow-window window)
  385.             (progn
  386.               (#_DragWindow :ptr wptr
  387.                             :long global-where
  388.                             :ptr (window-drag-rect window)))))))
  389.  
  390. (defmethod grow-window ((window window) &aux (pos (view-position window)))
  391.   (set-view-size  window
  392.                     (subtract-points (grow-gray-rect pos
  393.                                                      (view-size window)
  394.                                                      (window-manager-port)
  395.                                                     45)
  396.                                     pos)))
  397.  
  398. ;;;;;;;;;;;;;;;;;;;;;;;;
  399. ;;
  400. ;;  support for guides
  401. ;;
  402.  
  403.  
  404. (defmethod draw-dialog-guides ((window window))
  405.   (let* ((w-size (view-size window))
  406.          (w-height (point-v w-size))
  407.          (w-width (point-h w-size)))
  408.   (with-focused-view window
  409.     (with-pen-saved
  410.       (#_PenMode :word (position :patxor *pen-modes*))
  411.       (#_PenPat :ptr *gray-pattern*)
  412.       (dolist (guide (get-vertical-guides window))
  413.         (draw-one-guide window :vertical guide w-height))
  414.       (dolist (guide (get-horizontal-guides window))
  415.         (draw-one-guide window :horizontal guide w-width))))))
  416.  
  417. (defmethod draw-one-guide ((window window) direction position end)
  418.   "port, pattern, and mode must already be set"
  419.   (case direction
  420.     (:vertical
  421.      (#_MoveTo :word position
  422.                :word 0)
  423.      (#_LineTo :word position
  424.                :word end))
  425.     (:horizontal
  426.      (#_MoveTo :word 0
  427.                :word position)
  428.      (#_LineTo :word end
  429.                :word position))
  430.     (t (error "bad argument: ~s " direction))))
  431.  
  432. (defmethod add-guide ((window window) direction)
  433.   (draw-dialog-guides window)
  434.   (unwind-protect
  435.     (case direction
  436.       (:vertical
  437.        (push 50 (get-vertical-guides window)))
  438.       (:horizontal
  439.        (push 50 (get-horizontal-guides window)))
  440.       (t (error "bad argument: ~s " direction)))
  441.     (draw-dialog-guides window)))
  442.  
  443. (defmethod add-horizontal-guide ((window window))
  444.   (add-guide window :horizontal))
  445.  
  446. (defmethod add-vertical-guide ((window window))
  447.   (add-guide window :vertical))
  448.  
  449. (defmethod drag-guide ((window window) where
  450.                        &aux guide direction end extractor)
  451.   (let ((horizontal-guides (get-horizontal-guides window))
  452.         (vertical-guides (get-vertical-guides window)))
  453.     (cond
  454.      ((setq guide
  455.             (car (memq (point-h where) vertical-guides)))
  456.       (setq vertical-guides
  457.             (setf (get-vertical-guides window) (delete guide vertical-guides))
  458.             direction :vertical
  459.             end (point-v (view-size window))
  460.             extractor #'point-h))
  461.      ((setq guide
  462.             (car (memq (point-v where) horizontal-guides)))
  463.       (setq horizontal-guides 
  464.             (setf (get-horizontal-guides window) (delete guide horizontal-guides))
  465.             direction :horizontal
  466.             end (point-h (view-size window))
  467.             extractor #'point-v))
  468.      (t (error "bad argument: ~s " where)))
  469.     (with-focused-view window
  470.       (with-pen-saved
  471.         (#_PenMode :word (position :patxor *pen-modes*))
  472.         (#_PenPat :ptr *gray-pattern*)
  473.         (do* ((old-mouse (funcall extractor where)
  474.                          new-mouse)
  475.               (new-mouse old-mouse
  476.                          (funcall extractor (view-mouse-position window))))
  477.              ((not (mouse-down-p))
  478.               (when (> old-mouse 0)
  479.                 (if (eq direction :vertical)
  480.                   (when (< old-mouse (point-h (view-size window)))
  481.                     (setf (get-vertical-guides window)
  482.                           (push old-mouse vertical-guides)))
  483.                   (when (< old-mouse (point-v (view-size window)))
  484.                     (setf (get-horizontal-guides window)
  485.                           (push old-mouse horizontal-guides))))))
  486.           (draw-one-guide window direction old-mouse end)
  487.           (draw-one-guide window direction new-mouse end)
  488.           (sleep 1/60))))))
  489.  
  490. (defmethod guide-align ((window window) point)
  491.   (let* ((h (point-h point))
  492.          (v (point-v point)))
  493.     (when (setq point
  494.                 (car (member h (get-vertical-guides window) :test #'on-guide-p)))
  495.       (setq h point))
  496.     (when (setq point
  497.                 (car (member v (get-horizontal-guides window) :test #'on-guide-p)))
  498.       (setq v point))
  499.     (make-point h v)))
  500.  
  501. (defun on-guide-p (num-1 num-2)
  502.   (<= (abs (- num-1 num-2)) *guide-gravity*))
  503.  
  504. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  505. ;;
  506. ;;  support for selecting/moving/resizing dialog items
  507. ;;
  508.  
  509.  
  510. (defmethod select-dialog-item ((window window) item)
  511.   (pushnew item *selected-dialog-items*)
  512.   (with-focused-view window
  513.     (highlight-one-selected-item window item t)))
  514.  
  515. (defmethod unselect-dialog-item ((window window) item)
  516.   (setq *selected-dialog-items*
  517.         (delete item *selected-dialog-items*))
  518.   (with-focused-view window
  519.     (highlight-one-selected-item window item nil)))
  520.  
  521. (defmethod reset-selected-item-list ((window window))
  522.   (highlight-selected-items window nil)
  523.   (setq *selected-dialog-items* nil))
  524.  
  525. (defmethod highlight-selected-items ((window window) on-p &optional draw-p)
  526.   (with-focused-view window
  527.     (dolist (item *selected-dialog-items*)
  528.       (highlight-one-selected-item window item on-p draw-p))))
  529.  
  530. (defmethod highlight-one-selected-item ((window window) item on-p &optional draw-p)
  531.   "port should already be set"
  532.   (declare (optimize (speed 3) (safety 0)))
  533.   (declare (special on-p draw-p))       ; temporary until stack-consed closures
  534.   (let* (pos size end)
  535.     (setq pos (view-position item)
  536.           size (view-size item)
  537.           end (add-points pos size))
  538.     (let* ((delta 3)
  539.            (top (point-v pos))
  540.            (top-top (- top delta))
  541.            (bottom (point-v end))
  542.            (bottom-bottom (+ bottom delta))
  543.            (left (point-h pos))
  544.            (left-left (- left delta))
  545.            (right (point-h end))
  546.            (right-right (+ right delta))
  547.            (left-center (+ 1 left-left (ash (point-h size) -1)))
  548.            (right-center (+ left-center delta))
  549.            (top-center (+ 1 top-top (ash (point-v size) -1)))
  550.            (bottom-center (+ top-center delta)))
  551.       (declare (fixnum delta top top-top bottom bottom-bottom
  552.                        left left-left right right-right
  553.                        left-center right-center top-center bottom-center))
  554.       (rlet ((rect :rect))
  555.         (declare (special rect))        ; temporary until stack-consed closures
  556.         (flet ((do-rect (top bottom left right)
  557.                         (rset rect rect.top top)
  558.                         (rset rect rect.left left)
  559.                         (rset rect rect.bottom bottom)
  560.                         (rset rect rect.right right)
  561.                         (if on-p
  562.                           (if draw-p
  563.                             (#_PaintRect :ptr rect)
  564.                             (#_InvalRect :ptr rect))
  565.                           (progn
  566.                             (invalidate-corners 
  567.                              window
  568.                              (make-point left top)
  569.                              (make-point right bottom)
  570.                              t)))))
  571.           (declare (dynamic-extent do-rect))
  572.           (do-rect top-top top left-left left)
  573.           (do-rect top-top top left-center right-center)
  574.           (do-rect top-top top right right-right)
  575.           (do-rect top-center bottom-center left-left left)
  576.           (do-rect top-center bottom-center right right-right)
  577.           (do-rect bottom bottom-bottom left-left left)
  578.           (do-rect bottom bottom-bottom left-center right-center)
  579.           (do-rect bottom bottom-bottom right right-right))))))
  580.  
  581. (defmethod select-several-items ((window window) where &aux scratch)
  582.   (unless (shift-key-p)
  583.     (reset-selected-item-list window))
  584.   (rlet ((user-rect :rect)
  585.          (scratch-rect :rect)
  586.          (i-rect :rect))
  587.     (#_pt2rect :long where
  588.                :long (grow-gray-rect where 0 (wptr window) nil)
  589.                :ptr user-rect)
  590.     (dolist (item (dialog-items window))
  591.       (setq scratch (view-position item))
  592.       (rset i-rect :rect.topleft scratch)
  593.       (rset i-rect :rect.bottomright (add-points
  594.                                       scratch
  595.                                       (view-size item)))
  596.       (#_SectRect :ptr user-rect :ptr i-rect :ptr scratch-rect)
  597.       (unless (#_EmptyRect :ptr scratch-rect :boolean)
  598.         (select-dialog-item window item)))))
  599.  
  600. (defmethod grow-or-move-dialog-item ((window window) where item was-selected)
  601.   (while (eq where (view-mouse-position window))
  602.     (unless (mouse-down-p)
  603.       (if was-selected
  604.         (unselect-dialog-item window item)
  605.         (select-dialog-item window item))
  606.       (return-from grow-or-move-dialog-item)))
  607.   (select-dialog-item window item)
  608.   (let* (pos end)
  609.     (setq pos (view-position item)
  610.           end (add-points pos (view-size item)))
  611.     (rlet ((item-rect :rect
  612.                       :topleft pos
  613.                       :bottomright end))
  614.       (unwind-protect
  615.         (progn
  616.           (#_HideCursor)
  617.           (if (or (#_PtInRect where item-rect)
  618.                   (> (length *selected-dialog-items*) 1))
  619.             (move-selected-dialog-items window where item-rect)
  620.             (grow-dialog-item window item item-rect where)))
  621.         (#_ShowCursor)))))
  622.  
  623. (defmethod grow-dialog-item ((window window) item item-rect where &aux new-pos)
  624.   (highlight-one-selected-item window item nil)
  625.   (let* ((old-pos (rref item-rect :rect.topleft))
  626.          (old-size (subtract-points
  627.                     (rref item-rect :rect.bottomright)
  628.                     old-pos)))
  629.     (setq item-rect
  630.           (grow-item-outline window item-rect where))
  631.     (without-interrupts 
  632.      (invalidate-view item t)
  633.      (set-view-position item (setq new-pos
  634.                                    (rref item-rect :rect.topleft)))
  635.      (set-view-size item (subtract-points
  636.                           (rref item-rect :rect.bottomright)
  637.                           new-pos)))
  638.     (highlight-one-selected-item window item t)
  639.     (setq *dialog-change-undohook*
  640.           (cons "Undo Resize"
  641.                 #'(lambda ()
  642.                     (with-focused-view window
  643.                       (without-interrupts
  644.                        (highlight-one-selected-item window item nil)
  645.                        (set-view-size item old-size)
  646.                        (set-view-position item old-pos)
  647.                        (highlight-one-selected-item window item t))))))))
  648.  
  649. (defmethod grow-item-outline ((window window) rect where)
  650.   "destructively modifies the rect"
  651.   (let* ((flag nil)
  652.          (pos where)
  653.          (pos-h (point-h pos))
  654.          (pos-v (point-v pos))
  655.          (top (+ (rref rect :rect.top) 3))
  656.          (left (+ (rref rect :rect.left) 3))
  657.          (bottom (- (rref rect :rect.bottom) 3))
  658.          (right (- (rref rect :rect.right) 3))
  659.          (min-v (+ top 2))
  660.          (min-h (+ left 2))
  661.          (max-v (- bottom 2))
  662.          (max-h (- right 2)))
  663.     (setq flag
  664.           (cond ((< pos-h left)    ;on left side
  665.                  (cond
  666.                   ((< pos-v top) (setq min-h -4095 min-v -4095) :topleft)
  667.                   ((> pos-v bottom) (setq min-h -4095 max-v 4095) :bottomleft)
  668.                   (t (setq min-h -4095 min-v 0 max-v 0) :left)))
  669.                 ((> pos-h right)   ;on right side
  670.                  (cond
  671.                   ((< pos-v top) (setq max-h 4095 min-v -4095) :topright)
  672.                   ((> pos-v bottom) (setq max-h 4095 max-v 4095) :bottomright)
  673.                   (t (setq max-h 4095 min-v 0 max-v 0) :right)))
  674.                 (t                 ;in the middle
  675.                  (cond ((< pos-v top) (setq min-v -4095 min-h 0 max-h 0) :top)
  676.                        (t (setq max-v 4095 min-h 0 max-h 0) :bottom)))))
  677.     (with-focused-view window
  678.       (with-pen-saved
  679.         (with-clip-rect (rref (wptr window) :grafport.portrect)
  680.           (#_PenMode :word (position :patxor *pen-modes*))
  681.           (#_PenPat :ptr *gray-pattern*)
  682.           (#_FrameRect :ptr rect)
  683.           (setq pos (make-point (max min-h (min max-h (point-h pos)))
  684.                                 (max min-v (min max-v (point-v pos)))))
  685.           (do* ((old-mouse pos new-mouse)
  686.                 (new-mouse pos (view-mouse-position window)))
  687.                ((not (mouse-down-p)))
  688.             (setq new-mouse (make-point (max min-h (min max-h (point-h new-mouse)))
  689.                                         (max min-v (min max-v (point-v new-mouse)))))
  690.             (unless (eq old-mouse new-mouse)
  691.               (#_FrameRect :ptr rect)
  692.               (update-rect flag rect (subtract-points new-mouse old-mouse))
  693.               (#_FrameRect :ptr rect)))
  694.           (#_FrameRect :ptr rect)
  695.           rect)))))
  696.  
  697. (defun update-rect (flag rect delta)
  698.   (case flag
  699.     (:left (rset rect :rect.left (+ (rref rect :rect.left) (point-h delta))))
  700.     (:right (rset rect :rect.right (+ (rref rect :rect.right) (point-h delta))))
  701.     (:top (rset rect :rect.top (+ (rref rect :rect.top) (point-v delta))))
  702.     (:bottom (rset rect :rect.bottom (+ (rref rect :rect.bottom) (point-v delta))))
  703.     (:topleft (update-rect :top rect delta) (update-rect :left rect delta))
  704.     (:bottomright (update-rect :bottom rect delta) (update-rect :right rect delta))
  705.     (:topright (update-rect :top rect delta) (update-rect :right rect delta))
  706.     (:bottomleft (update-rect :bottom rect delta) (update-rect :left rect delta))))
  707.  
  708. (defmethod move-selected-dialog-items ((window window) where total-rect &aux
  709.                                        (item-old-pos-a-list ())
  710.                                        (constrained (shift-key-p))
  711.                                        (wptr (wptr window))
  712.                                        reg pos)
  713.   (when (option-key-p)
  714.     (duplicate-selected-dialog-items window))
  715.   (rlet ((one-rect :rect))
  716.     (dolist (item *selected-dialog-items*)
  717.       (highlight-one-selected-item window item nil)
  718.       (rset one-rect :rect.topleft (setq pos (view-position item)))
  719.       (rset one-rect :rect.bottomright (add-points pos (view-size item)))
  720.       (#_UnionRect :ptr one-rect
  721.                    :ptr total-rect
  722.                    :ptr total-rect)
  723.       (push (cons item pos) item-old-pos-a-list)))
  724.   (setq constrained
  725.         (if constrained
  726.             (if (eq (point-h where) (point-h (view-mouse-position window)))
  727.                 2   ;vertical constraint
  728.                 1)  ;horizontal constraint
  729.             0))
  730.   (unwind-protect
  731.     (progn
  732.       (setq reg (#_NewRgn :ptr))
  733.       (#_RectRgn :ptr reg :ptr total-rect)
  734.       (rlet ((slop-rect :rect))
  735.         (copy-record (rref wptr windowRecord.portrect) :rect slop-rect)
  736.         (#_InsetRect :ptr slop-rect :word -10 :word -10)
  737.         (setq pos 
  738.               (#_DragGrayRgn :ptr reg
  739.                              :long where 
  740.                              :ptr (rref wptr windowRecord.portrect)
  741.                              :ptr slop-rect
  742.                              :word constrained
  743.                              :ptr (ccl::%null-ptr)
  744.                              :long))))
  745.     (when reg
  746.       (#_DisposeRgn :ptr reg)
  747.       (unless (eql -32768 (point-h pos))   ;some Mac magic number.  should be an equate
  748.         (setq pos (best-guide-delta window total-rect pos))
  749.         (dolist (item *selected-dialog-items*)
  750.           (without-interrupts
  751.            (set-view-position item (add-points pos (view-position item)))
  752.            (invalidate-view item)
  753.            (highlight-one-selected-item window item t)))
  754.         (setq *dialog-change-undohook*
  755.               (cons "Undo Move"
  756.                     #'(lambda ()
  757.                         (reset-selected-item-list window)
  758.                         (dolist (item/pos item-old-pos-a-list)
  759.                           (set-view-position (car item/pos) (cdr item/pos))
  760.                           (select-dialog-item window (car item/pos))))))))))
  761.  
  762. (defmethod best-guide-delta ((window window) rect delta)
  763.   (let* ((topleft (add-points delta (rref rect :rect.topleft)))
  764.          (bottomright (add-points delta (rref rect :rect.bottomright)))
  765.          (new-tl topleft)
  766.          (new-br bottomright)
  767.          (new-delta-h (point-h delta))
  768.          (new-delta-v (point-v delta))
  769.          temp1
  770.          temp2)
  771.     (setq topleft (guide-align window topleft))
  772.     (setq bottomright (guide-align window bottomright))
  773.     (if (neq (setq temp1 (point-v topleft))
  774.              (setq temp2 (point-v new-tl)))
  775.         (setq new-delta-v (+ new-delta-v (- temp1 temp2)))
  776.         (when (neq (setq temp1 (point-v bottomright))
  777.                    (setq temp2 (point-v new-br)))
  778.           (setq new-delta-v (+ new-delta-v (- temp1 temp2)))))
  779.     (if (neq (setq temp1 (point-h topleft))
  780.              (setq temp2 (point-h new-tl)))
  781.         (setq new-delta-h (+ new-delta-h (- temp1 temp2)))
  782.         (when (neq (setq temp1 (point-h bottomright))
  783.                    (setq temp2 (point-h new-br)))
  784.           (setq new-delta-h (+ new-delta-h (- temp1 temp2)))))
  785.     (make-point new-delta-h new-delta-v)))
  786.  
  787.  
  788.  
  789. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  790. ;;
  791. ;;  code for adding dialog-items
  792. ;;
  793.  
  794.  
  795. (defmethod duplicate-selected-dialog-items ((window window))
  796.   (let ((new-items (copy-selected-dialog-items window)))
  797.     (reset-selected-item-list window)
  798.     (apply #'add-subviews window new-items)
  799.     (dolist (item new-items)
  800.       (select-dialog-item window item))))
  801.  
  802. ;;;;;;;;;;;;;;;;;;;;;;;;
  803. ;;
  804. ;;  item selection palette
  805. ;;
  806.  
  807. (defmethod initialize-instance ((palette item-palette) &rest initargs &key 
  808.                                 (window-show t))
  809.   (declare (dynamic-extent initargs))
  810.   (apply #'call-next-method
  811.          palette
  812.          :window-show nil
  813.          :view-size *item-palette-size*
  814.          :view-position *item-palette-position*
  815.          initargs)
  816.   (apply #'add-subviews
  817.          palette
  818.          *prototype-dialog-items*)
  819.   (when window-show
  820.     (window-show palette))
  821.   (setq *current-item-palette* palette))
  822.  
  823. (defmethod install-view-in-window :after (view (palette item-palette))
  824.   (let* ((size (view-size palette))
  825.          (view-br (add-points (view-position view) (view-size view)))
  826.          (max-h (max (point-h size) (+ 5 (point-h view-br))))
  827.          (max-v (max (point-v size) (+ 5 (point-v view-br)))))
  828.     (unless (eql size (setq size (make-point max-h max-v)))
  829.       (set-view-size palette size))))
  830.  
  831. (defmethod ccl::view-find-vacant-position ((palette item-palette) subview)
  832.   (let ((total-rgn (#_NewRgn))
  833.         (rgn (#_NewRgn))
  834.         (size (view-size palette))
  835.         (subview-size (view-size subview)))
  836.     (unless (>= (point-v size) (point-v subview-size))
  837.       (setq size (set-view-size palette (point-h size) (+ 10 (point-v subview-size)))))
  838.     (unwind-protect
  839.       (progn
  840.         (dolist (view (subviews palette))
  841.           (unless (eq view subview)
  842.             (multiple-value-bind (tl br) (view-corners view)
  843.               (#_SetRectRgn :ptr rgn :long tl :long br)
  844.               (#_UnionRgn rgn total-rgn total-rgn))))
  845.         (let ((pos (call-next-method)))
  846.           (#_SetRectRgn :ptr rgn :long pos :long (add-points pos (view-size subview)))
  847.           (#_SectRgn rgn total-rgn rgn)
  848.           (if (#_EmptyRgn rgn)
  849.             pos
  850.             (progn
  851.               (setf (slot-value subview 'view-position) pos)
  852.               (set-view-size palette 
  853.                              (max (point-h size) (+ 5 (point-h subview-size)))
  854.                              (+ (href total-rgn :region.rgnbbox.bottom) (point-v subview-size) 15))
  855.               (setf (slot-value subview 'view-position) nil)
  856.               (call-next-method)))))
  857.       (#_DisposeRgn rgn)
  858.       (#_DisposeRgn total-rgn))))
  859.  
  860. (defmethod window-close-event-handler ((palette item-palette))
  861.   (use-dialogs))
  862.  
  863. (defmethod window-close :before ((palette item-palette))
  864.   (setq *current-item-palette* nil)
  865.   (setq *item-palette-position* (view-position palette)
  866.         *item-palette-size* (view-size palette)))
  867.  
  868. (defmethod view-click-event-handler ((palette item-palette) where)
  869.   (let* ((item (find-view-containing-point palette where nil t)))
  870.     (when item
  871.       (select-and-add-dialog-item palette item where))))
  872.  
  873. (defmethod select-and-add-dialog-item ((palette item-palette) item mouse-pos)
  874.   (declare (optimize (debug 3)))
  875.   (let* ((offset (view-position palette))
  876.          (topleft (add-points offset (view-position item)))
  877.          (bottomright  (add-points topleft (view-size item)))
  878.          (reg (#_NewRgn :ptr))
  879.          (wmgrPort (window-manager-port))
  880.          mouse-offset)
  881.     (setq mouse-pos (add-points mouse-pos offset)
  882.           mouse-offset (subtract-points mouse-pos topleft))
  883.     (unwind-protect
  884.       (with-port wmgrPort
  885.         (rlet ((rect :rect
  886.                      :topleft topleft
  887.                      :bottomright bottomright))
  888.           (#_RectRgn :ptr reg :ptr rect)            ;get a region of the item outline
  889.           (with-macptrs ((visrgn (rref wmgrPort :grafport.visrgn)))
  890.             (setf (rref rect :rect.topleft) (rref visrgn :region.rgnBbox.topLeft))
  891.             (setf (rref rect :rect.bottomright) (rref visrgn :region.rgnbbox.botRight)))
  892.           (with-clip-rect rect
  893.             (let* ((pos (add-points mouse-pos (#_DragGrayRgn :ptr reg
  894.                                                              :long mouse-pos
  895.                                                              :ptr rect
  896.                                                              :ptr rect
  897.                                                              :word 0         ;not constrained
  898.                                                              :ptr (ccl::%null-ptr)
  899.                                                              :long)))
  900.                    (window (front-window))
  901.                    (wpos (view-position window))
  902.                    (size (add-points wpos (view-size window))))
  903.               (when (and (ccl::editing-dialogs-p window)
  904.                          (point>= pos wpos)
  905.                          (point< pos size))
  906.                 (add-subviews 
  907.                  window
  908.                  (make-instance (type-of item)
  909.                                 :dialog-item-text "Untitled"
  910.                                 :view-position (subtract-points
  911.                                                 (subtract-points pos wpos)
  912.                                                 mouse-offset))))))))
  913.       (#_DisposeRgn :ptr reg)))
  914.   (menu-update *edit-menu*))
  915.  
  916.  
  917. (defun point< (pt1 pt2)
  918.   (and (< (point-h pt1) (point-h pt2))
  919.        (< (point-v pt1) (point-v pt2))))
  920.  
  921. (defun point>= (pt1 pt2)
  922.   (and (>= (point-h pt1) (point-h pt2))
  923.        (>= (point-v pt1) (point-v pt2))))
  924.  
  925.  
  926. (defun add-editable-dialog-item (proto-item)
  927.   (let* ((class (class-of proto-item)))
  928.     (when (member class *prototype-dialog-items* :key #'class-of)
  929.       (remove-editable-dialog-item class))
  930.     (push proto-item *prototype-dialog-items*)
  931.     (when *current-item-palette*
  932.       (add-subviews *current-item-palette* proto-item))))
  933.  
  934. (defun remove-editable-dialog-item (class)
  935.   (let* ((item (find class *prototype-dialog-items* :key #'class-of)))
  936.     (when item
  937.       (setq *prototype-dialog-items*
  938.             (delete item *prototype-dialog-items*))
  939.       (when *current-item-palette*
  940.         (remove-subviews *current-item-palette* item))
  941.       (setf (slot-value item 'view-position) nil))))
  942.  
  943.  
  944. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  945. ;;
  946. ;;  dialog for creating new dialog windows
  947. ;;
  948.  
  949.  
  950. (defmethod dialog-item-action :before ((button frame-window-r-b))
  951.   (dialog-item-enable (find-named-sibling button 'item-close-box)))
  952.  
  953. (defmethod dialog-item-action :before ((button box-window-r-b))
  954.   (let ((close-box (find-named-sibling button 'item-close-box)))
  955.     (check-box-uncheck close-box)
  956.     (dialog-item-disable close-box)))
  957.  
  958. (defun create-new-dialog ()
  959.   (let* ((options nil))
  960.     (setq options
  961.           (modal-dialog
  962.            (make-instance
  963.             'dialog
  964.             :window-type :double-edge-box
  965.             :window-title "Untitled Dialog"
  966.             :view-position '(:top 100)
  967.             :view-size #@(342 165)
  968.             :window-show nil
  969.             :view-subviews
  970.             (list
  971.              (make-dialog-item 'static-text-dialog-item
  972.                                #@(3 3) #@(206 18)
  973.                                "Select Dialog Window Options:")
  974.              (make-dialog-item 'button-dialog-item
  975.                                #@(190 140) #@(62 16) "OK"
  976.                                #'(lambda (item)
  977.                                    (let ((dialog (view-container item)))
  978.                                      (return-from-modal-dialog
  979.                                       (list
  980.                                        (check-box-checked-p
  981.                                         (view-named 'item-color-window dialog))
  982.                                        (dialog-item-attribute
  983.                                         (pushed-radio-button dialog))
  984.                                        (check-box-checked-p
  985.                                         (view-named 'item-close-box dialog))))))
  986.                                :default-button t)
  987.              (make-dialog-item 'button-dialog-item
  988.                                #@(269 140) #@(62 16) "Cancel"
  989.                                #'(lambda (item)
  990.                                    (declare (ignore item))
  991.                                    (return-from-modal-dialog :cancel)))
  992.              (make-dialog-item 'check-box-dialog-item
  993.                                #@(4 117) #@(139 17) "Include Close Box" nil
  994.                                :check-box-checked-p t
  995.                                :view-nick-name 'item-close-box)
  996.              (make-dialog-item 'check-box-dialog-item
  997.                                #@(4 140) #@(139 16) "Color Window" nil
  998.                                :view-nick-name 'item-color-window)
  999.              (make-dialog-item 'frame-window-r-b
  1000.                                #@(4 26) #@(94 16) "Document" nil
  1001.                                :radio-button-pushed-p t
  1002.                                :attribute :document)
  1003.              (make-dialog-item 'frame-window-r-b
  1004.                                #@(4 49) #@(163 16) "Document with Grow" nil
  1005.                                :attribute :document-with-grow)
  1006.              (make-dialog-item 'frame-window-r-b
  1007.                                #@(4 71) #@(163 16) "Document with Zoom" nil
  1008.                                :attribute :document-with-zoom)
  1009.              (make-dialog-item 'frame-window-r-b
  1010.                                #@(4 93) #@(72 16) "Tool" nil
  1011.                                :attribute :tool)
  1012.              (make-dialog-item 'box-window-r-b
  1013.                                #@(190 25) #@(133 17) "Single Edge Box" nil
  1014.                                :attribute :single-edge-box)
  1015.              (make-dialog-item 'box-window-r-b
  1016.                                #@(190 49) #@(130 16) "Double Edge Box" nil
  1017.                                :attribute :double-edge-box)
  1018.              (make-dialog-item 'box-window-r-b
  1019.                                #@(190 71) #@(134 16) "Shadow Edge Box" nil
  1020.                                :attribute :shadow-edge-box)))))
  1021.     (make-instance (if (pop options)
  1022.                      'color-dialog
  1023.                      'dialog)
  1024.                    :window-type (pop options)
  1025.                    :close-box-p (pop options)
  1026.                    :view-size #@(300 150)
  1027.                    :view-position '(:top 60))))
  1028.  
  1029. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1030. ;;
  1031. ;;  code for editing features of a dialog
  1032. ;;
  1033.  
  1034. (defmethod edit-dialog ((window window))
  1035.   (modal-dialog
  1036.    (make-instance 'dialog-editor
  1037.                   :dialog window)))
  1038.  
  1039.  
  1040. (defmethod initialize-instance ((editor dialog-editor) &rest initargs &key dialog)
  1041.   (declare (dynamic-extent initargs))
  1042.   (apply #'call-next-method
  1043.          editor
  1044.          :window-title (format nil "~s Dialog" (window-title dialog))
  1045.          initargs)
  1046.   (add-control-items editor dialog)
  1047.   (add-attribute-items editor dialog))
  1048.  
  1049. (defmethod add-control-items ((editor dialog-editor) dialog)
  1050.   (declare (ignore dialog))
  1051.   (add-subviews
  1052.    editor
  1053.    (make-dialog-item 'button-dialog-item
  1054.                      #@(247 42) #@(50 16) "OK"
  1055.                      #'(lambda (item &aux new-pos title)
  1056.                          (let* ((editor (view-container item))
  1057.                                 (dialog (dialog-editor-dialog editor)))
  1058.                            (setq new-pos
  1059.                                  (read-from-string
  1060.                                   (dialog-item-text
  1061.                                    (view-named 'item-view-position editor)))
  1062.                                  title 
  1063.                                  (dialog-item-text 
  1064.                                   (view-named 'item-title editor)))
  1065.                            (set-window-title dialog title)
  1066.                            (set-view-position dialog new-pos))
  1067.                          (return-from-modal-dialog t))
  1068.                      :default-button t)
  1069.    (make-dialog-item 'button-dialog-item
  1070.                      #@(310 42) #@(50 16) "Cancel"
  1071.                      #'(lambda (item)
  1072.                          (declare (ignore item))
  1073.                          (return-from-modal-dialog :cancel)))))
  1074.  
  1075. (defmethod add-attribute-items ((editor dialog-editor) dialog)
  1076.   (let* ((the-pos (window-centered-p dialog)))
  1077.     (when (fixnump the-pos) (setq the-pos (ppoint the-pos)))
  1078.     (add-subviews
  1079.      editor
  1080.      (make-dialog-item 'static-text-dialog-item
  1081.                        #@(7 11) #@(92 15) "Window Title:")
  1082.      (make-dialog-item 'editable-text-dialog-item
  1083.                        #@(104 11) #@(252 16) (window-title dialog) nil
  1084.                        :allow-returns nil
  1085.                        :view-nick-name 'item-title)
  1086.      (make-dialog-item 'static-text-dialog-item
  1087.                        #@(7 42) #@(130 16) "Window Position:" nil)
  1088.      (make-dialog-item 'editable-text-dialog-item
  1089.                        #@(130 42) #@(105 16) (let ((*print-base* 10))
  1090.                                                (format nil "~s" the-pos)) nil
  1091.                        :view-nick-name 'item-view-position))))
  1092.